home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / dumper.lisp < prev    next >
Text File  |  1993-07-17  |  21KB  |  524 lines
  1. ;-*-mode: Lisp; Base: 8.; package: Boxer; fonts:cptfont -*-
  2.  
  3. ;;; This is a machine independent binary dumper for the BOXER system 
  4. ;;;
  5. ;;; (C) Copyright 1984, 1985 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; Permission to use, copy, modify, distribute, and sell this software
  8. ;;; and its documentation for any purpose is hereby granted without fee,
  9. ;;; provided that the above copyright notice appear in all copies and that
  10. ;;; both that copyright notice and this permission notice appear in
  11. ;;; supporting documentation, and that the name of M.I.T. not be used in
  12. ;;; advertising or publicity pertaining to distribution of the software
  13. ;;; without specific, written prior permission.  M.I.T. makes no
  14. ;;; representations about the suitability of this software for any
  15. ;;; purpose.  It is provided "as is" without express or implied warranty.
  16. ;;;
  17. ;;;
  18. ;;;                          +-Data--+
  19. ;;; This file is part of the | BOXER | system.
  20. ;;;                          +-------+
  21. ;;;
  22. ;;; It is meant to convert box structure into a binary format for storing in files
  23. ;;; 
  24. ;;; The boxer world has three kinds of objects which must be dumped out
  25. ;;; They are: CHARACTERS, ROWS, and BOXES.
  26. ;;;
  27. ;;; CHARACTERS are dumped out as themselves, that is, fixnums
  28. ;;;
  29. ;;; ROWS are essentially arrays of characters and are dumped out as such keeping in mind that
  30. ;;; some of the characters may be BOXES
  31. ;;;
  32. ;;; BOXES come in three major types.  Regular, Port and Graphics.
  33. ;;;    ALL boxes have to preserve their display info (i.e. desired size), their name,
  34. ;;;    binding information (the STATIC-VARIABLES-ALIST) and the superior row
  35. ;;;
  36. ;;;    GRAPHICS boxes have to dump out their bit-arrays (although in the case of turtle boxes
  37. ;;;    it may be optional)
  38. ;;;
  39. ;;;    REGULAR boxes will have to keep track of their inferior rows,
  40. ;;;    and Any pointers to PORTS 
  41. ;;;
  42. ;;;    PORTS only have to keep track of the ported to box
  43.  
  44. ;*********************************************************************************************
  45. ;*                             DUMPING   FUNCTIONS                                           *
  46. ;*********************************************************************************************
  47.  
  48. ;;; Top level Dumping Function (this is called from BOXER and takes a <box> and a <filename>)
  49.  
  50. (DEFUN DUMP-TOP-LEVEL-BOX (BOX FILENAME &OPTIONAL FILE-ATTRIBUTE-LIST)
  51.   (UNLESS (GET (LOCF FILE-ATTRIBUTE-LIST) ':PACKAGE)
  52.     (PUTPROP (LOCF FILE-ATTRIBUTE-LIST) ':BOXER ':PACKAGE))
  53.   (WRITING-BIN-FILE (BOX STREAM FILENAME)
  54.     (DUMP-ATTRIBUTE-LIST FILE-ATTRIBUTE-LIST STREAM)
  55.     (TELL BOX :DUMP-SELF STREAM)))
  56.  
  57. ;;;minimal debugging utilities...
  58. (DEFMACRO TEST-ENVIRONMENT (&BODY BODY)
  59.   `(LET ((*BIN-LOAD-INDEX* 0)
  60.      (*BIN-LOAD-TABLE* (MAKE-ARRAY 1000))
  61.      (*BIN-NEXT-COMMAND-FUNCTION* 'BIN-LOAD-NEXT-COMMAND))
  62.      (PROGN . ,BODY)))
  63.  
  64. (DEFUN FILE-TESTER (PATHNAME BUFFER)
  65.   (WITH-OPEN-FILE (STREAM PATHNAME ':DIRECTION ':INPUT ':CHARACTERS NIL)
  66.     (ZWEI:WITH-EDITOR-STREAM
  67.       (OUT ':BUFFER-NAME BUFFER ':CREATE-P T)
  68.       (TEST-ENVIRONMENT      
  69.     (*CATCH 'BIN-LOAD-DONE
  70.       (PRINT-OUT-LOOP STREAM OUT))))))
  71.  
  72. (DEFUN PRINT-SYMBOL-TABLE (PATHNAME BUFFER)
  73.   (WITH-OPEN-FILE (STREAM PATHNAME ':DIRECTION ':INPUT ':CHARACTERS NIL)
  74.     (ZWEI:WITH-EDITOR-STREAM
  75.       (OUT ':BUFFER-NAME BUFFER ':CREATE-P T)
  76.       (LOADING-BIN-FILE (STREAM 'BIN-LOAD-NEXT-COMMAND NIL)
  77.     (LET ((PACKAGE (PKG-FIND-PACKAGE 'BOXER)))
  78.       (BIN-LOAD-TOP-LEVEL STREAM))
  79.     (FORMAT OUT "~%~%   ***  THE  LOAD  TABLE  ***~%")
  80.     (LOOP FOR I FROM 0 TO *BIN-LOAD-INDEX*
  81.           DO (FORMAT OUT "~%~o: ~s" I (AREF *BIN-LOAD-TABLE* I)))))))
  82.  
  83. (DEFUN DA-WHOLE-THING (PATHNAME BUFFER)
  84.   (FILE-TESTER PATHNAME BUFFER)
  85.   (PRINT-SYMBOL-TABLE PATHNAME BUFFER))
  86.  
  87. (DEFUN PRINT-OUT-LOOP (STREAM OUT &OPTIONAL (PAD NIL))
  88.   (LOOP
  89.     DOING (LET ((NUMBER (TELL STREAM :TYI)))
  90.         (WHEN PAD (FORMAT OUT "   "))
  91.         (COND ((NOT (NUMBERP NUMBER)) (FORMAT OUT "~s~%" NUMBER)) 
  92.           ((= NUMBER BIN-OP-EOF)(*THROW 'BIN-LOAD-DONE T))
  93.           ((= NUMBER BIN-OP-END-OF-BOX)
  94.            (FORMAT OUT "~%BIN-OP-END-OF-BOX")
  95.            (*THROW 'BOX-DONE T))
  96.           ((BIN-OP-DISPATCH *BIN-OP-COMMAND-NAME-TABLE*
  97.                     (DECODE-BIN-OPCODE NUMBER))
  98.            (MULTIPLE-VALUE-BIND (INDEX ARG)
  99.                (DECODE-BIN-OPCODE NUMBER)
  100.              (PRINT-OUT-BIN-COMMAND STREAM INDEX ARG OUT)))
  101.           (T (FORMAT OUT "~o  " NUMBER))))))
  102.  
  103. (DEFUN PRINT-OUT-BIN-COMMAND (INSTREAM INDEX ARG OUTSTREAM)
  104.   (LET ((COMMAND-NAME (BIN-OP-DISPATCH *BIN-OP-COMMAND-NAME-TABLE* INDEX)))
  105.     (COND ((MEMQ COMMAND-NAME '(BIN-OP-DOIT-BOX BIN-OP-DATA-BOX BIN-OP-PORT-BOX
  106.                         BIN-OP-GRAPHICS-BOX BIN-OP-TURTLE-BOX))
  107.        (FORMAT OUTSTREAM "~%~S~%" COMMAND-NAME)
  108.        (*CATCH 'BOX-DONE
  109.          (PRINT-OUT-LOOP INSTREAM OUTSTREAM T)))
  110.       ;; numbers
  111.       ((EQ COMMAND-NAME 'BIN-OP-NUMBER-IMMEDIATE)
  112.        (FORMAT OUTSTREAM "~S~%" (FUNCALL 'LOAD-BIN-OP-NUMBER-IMMEDIATE INSTREAM ARG)))
  113.       ((EQ COMMAND-NAME 'BIN-OP-POSITIVE-FIXNUM)
  114.        (FORMAT OUTSTREAM "~d~%" (FUNCALL 'LOAD-BIN-OP-POSITIVE-FIXNUM INSTREAM)))
  115.       ((EQ COMMAND-NAME 'BIN-OP-NEGATIVE-FIXNUM)
  116.        (FORMAT OUTSTREAM "~d~%" (FUNCALL 'LOAD-BIN-OP-NEGATIVE-FIXNUM INSTREAM)))
  117.       ((EQ COMMAND-NAME 'BIN-OP-POSITIVE-FLOAT)
  118.        (FORMAT OUTSTREAM "~S~%" (FUNCALL 'LOAD-BIN-OP-POSITIVE-FLOAT INSTREAM)))
  119.       ((EQ COMMAND-NAME 'BIN-OP-NEGATIVE-FLOAT)
  120.        (FORMAT OUTSTREAM "~S~%" (FUNCALL 'LOAD-BIN-OP-NEGATIVE-FLOAT INSTREAM)))
  121.       ;; strings
  122.       ((EQ COMMAND-NAME 'BIN-OP-STRING-IMMEDIATE)
  123.        (FORMAT OUTSTREAM "~S ~%" (FUNCALL 'LOAD-BIN-OP-STRING-IMMEDIATE INSTREAM ARG)))
  124.       ((NULL ARG)(FORMAT OUTSTREAM "~S~%" COMMAND-NAME))
  125.       (T (FORMAT OUTSTREAM "~S   ~o~%" COMMAND-NAME ARG)))))
  126.  
  127. ;*********************************************************************************************
  128.  
  129. (DEFUN START-BIN-FILE (STREAM)
  130.   (SEND *BIN-DUMP-TABLE* ':CLEAR-HASH)
  131.   (TELL STREAM :TYO BIN-OP-FORMAT-VERSION)
  132.   (DUMP-BOXER-THING *VERSION-NUMBER* STREAM))
  133.  
  134. (DEFUN END-BIN-FILE (STREAM)
  135.   (TELL STREAM :TYO BIN-OP-EOF)
  136.   (CLOSE STREAM)
  137.   (TELL STREAM :TRUENAME))
  138.  
  139. (DEFUN ENTER-TABLE (FORM &OPTIONAL STREAM (EXPLICIT NIL))
  140.   (WHEN EXPLICIT (TELL STREAM :TYO BIN-OP-TABLE-STORE))
  141.   (SEND *BIN-DUMP-TABLE* ':PUT-HASH FORM *BIN-DUMP-INDEX*)
  142.   (INCF *BIN-DUMP-INDEX*))
  143.  
  144. ;; this is here so it will get open coded into DUMP-BOXER-THING
  145. (DEFSUBST SIMPLE-CONS? (X)
  146.   (AND (LISTP X) (ATOM (CDR X)) (NOT-NULL (CDR X))))
  147.  
  148. (DEFUN DUMP-BOXER-THING (THING STREAM &AUX INDEX)
  149.   (COND ((SETQ INDEX (TELL *BIN-DUMP-TABLE* :GET-HASH THING))
  150.      ;; thing is EQ to something which has already been dumped
  151.      (DUMP-TABLE-LOOKUP STREAM INDEX))
  152.     ((SYMBOLP THING) (DUMP-SYMBOL THING STREAM))
  153.     ((FIXP THING) (DUMP-FIXNUM THING STREAM))
  154.     ((FLOATP THING) (DUMP-FLOAT THING STREAM))
  155.     ((STRINGP THING) (DUMP-STRING THING STREAM))
  156.     ((SIMPLE-CONS? THING) (DUMP-SIMPLE-CONS THING STREAM))
  157.     ((LISTP THING) (DUMP-LIST THING STREAM))
  158.     ((GRAPHICS-SHEET? THING) (DUMP-GRAPHICS-SHEET THING STREAM))
  159.     ((ARRAYP THING) (DUMP-ARRAY THING STREAM))
  160.     ;((CHA? THING) (DUMP-CHA THING STREAM))
  161.     ((ROW? THING) (DUMP-ROW THING STREAM))
  162.     ((BOX? THING) (DUMP-BOX THING STREAM))
  163.     ((TURTLE? THING) (DUMP-TURTLE THING STREAM))
  164.     ((GRAPHICS-OBJECT? THING) (DUMP-GRAPHICS-OBJECT THING STREAM))
  165.     (T
  166.      (FERROR "Sorry, don't know how to dump ~S " THING))))
  167.  
  168. (DEFUN DUMP-ATTRIBUTE-LIST (PLIST STREAM)
  169.   (LET ((PKG (GET (LOCF PLIST) ':PACKAGE)))
  170.     (AND PKG (SETQ *BIN-DUMP-PACKAGE* (PKG-FIND-PACKAGE PKG))))
  171.   (FUNCALL STREAM ':TYO BIN-OP-FILE-PROPERTY-LIST)
  172.   ;; Put package prefixes on everything in the plist since it will be loaded in
  173.   ;; the wrong package.  This way the symbols in the plist will always
  174.   ;; be loaded into exactly the same package they were dumped from,
  175.   ;; while the rest of the symbols in the file will be free to follow
  176.   ;; the usual rules for intern.
  177.   (LET ((*BIN-DUMP-PACKAGE* NIL))
  178.     (PUTPROP (LOCF PLIST) #-LMITI ':ROW-MAJOR #+LMITI ':COLUMN-MAJOR ':BIT-ARRAY-ORDER)
  179.     (DUMP-BOXER-THING PLIST STREAM)))
  180.  
  181. (DEFUN DUMP-TABLE-LOOKUP (STREAM INDEX)
  182.   (COND ((< INDEX %%BIN-OP-IM-ARG-SIZE)
  183.      ;; will it fit into 20 bit immediate arg ?
  184.      (TELL STREAM :TYO (DPB BIN-OP-TABLE-FETCH-IMMEDIATE %%BIN-OP-HIGH INDEX)))
  185.     ((< INDEX %%BIN-OP-ARG-SIZE)
  186.      ;; will it fit into a 24 bit fixnum ?
  187.      (TELL STREAM :TYO BIN-OP-TABLE-FETCH)
  188.      (TELL STREAM :TYO INDEX))
  189.     (T
  190.      ;; figure out what to do if there are > 64K objects some other time
  191.      (FERROR "The dump index ~D ,won't fit inside a 16 bit fixnum" INDEX))))
  192.  
  193. (DEFUN DUMP-SYMBOL (SYMBOL STREAM)
  194.   (ENTER-TABLE SYMBOL)
  195.   (COND ((NULL (SYMBOL-PACKAGE SYMBOL))
  196.      (TELL STREAM :TYO BIN-OP-PACKAGE-SYMBOL)
  197.      (DUMP-BOXER-THING 'NIL STREAM))
  198.     (T
  199.      (LET ((PACKAGE-STRING #-REL4(PKG-NAME (SYMBOL-PACKAGE SYMBOL))
  200.                    #+REL4(IF (EQ SI:PKG-USER-PACKAGE (SYMBOL-PACKAGE SYMBOL))
  201.                      ;; A name with a colon (hopefully)
  202.                      (PKG-NAME PKG-KEYWORD-PACKAGE)
  203.                      (PKG-NAME (SYMBOL-PACKAGE SYMBOL)))))
  204.        (COND ((NULL PACKAGE-STRING)
  205.           (TELL STREAM :TYO BIN-OP-SYMBOL))
  206.          (T
  207.           (TELL STREAM :TYO BIN-OP-PACKAGE-SYMBOL)
  208.             (DUMP-BOXER-THING PACKAGE-STRING STREAM))))))
  209.   (DUMP-BOXER-THING (GET-PNAME SYMBOL) STREAM))
  210.  
  211. ;; remember to leave a bit for the sign bit
  212. (DEFSUBST SMALL-FIX? (NUMBER)
  213.   (< (- (ash %%BIN-OP-IM-ARG-SIZE -1)) NUMBER (ash %%BIN-OP-IM-ARG-SIZE -1)))
  214.  
  215. (DEFSUBST DUMP-SMALL-FIXNUM (NUMBER STREAM)
  216.   (TELL STREAM :TYO (DPB BIN-OP-NUMBER-IMMEDIATE %%BIN-OP-HIGH (LDB 0014 NUMBER))))
  217.  
  218. (DEFSUBST DUMP-LARGE-FIXNUM (NUMBER STREAM)
  219.   (COND ((MINUSP NUMBER)
  220.      (TELL STREAM :TYO BIN-OP-NEGATIVE-FIXNUM)
  221.      (LET ((LENGTH (// (+ (HAULONG (- NUMBER)) 15.) 16.)))
  222.        (DUMP-BOXER-THING LENGTH STREAM)
  223.        (LOOP FOR I FROM 0 BELOW LENGTH
  224.          FOR POS FROM 0 BY 16.
  225.          DO (TELL STREAM :TYO (LOAD-BYTE (- NUMBER) POS 16.)))))
  226.     (T
  227.      (TELL STREAM :TYO BIN-OP-POSITIVE-FIXNUM)
  228.      (LET ((LENGTH (// (+ (HAULONG NUMBER) 15.) 16.)))
  229.        (DUMP-BOXER-THING LENGTH STREAM)
  230.        (LOOP FOR I FROM 0 BELOW LENGTH
  231.          FOR POS FROM 0 BY 16.
  232.          DO (TELL STREAM :TYO (LOAD-BYTE NUMBER POS 16.)))))))
  233.  
  234. (DEFUN DUMP-FIXNUM (NUM STREAM)
  235.   (IF (SMALL-FIX? NUM)
  236.       (DUMP-SMALL-FIXNUM NUM STREAM)
  237.       (DUMP-LARGE-FIXNUM NUM STREAM)))
  238.  
  239. (DEFUN DUMP-FLOAT (NUMBER STREAM)
  240.   (IF ( NUMBER 0)
  241.       (TELL STREAM :TYO BIN-OP-POSITIVE-FLOAT)
  242.       (SETQ NUMBER (- NUMBER))
  243.       (TELL STREAM :TYO BIN-OP-NEGATIVE-FLOAT))
  244.   (LET ((MANTISSA (SI:FLONUM-MANTISSA NUMBER #-(OR LMITI 3600)(SMALL-FLOATP NUMBER) #+3600 NIL))
  245.     (EXPONENT (SI:FLONUM-EXPONENT NUMBER #-(OR LMITI 3600)(SMALL-FLOATP NUMBER) #+3600 NIL)))
  246.     (AND (ZEROP MANTISSA) (SETQ EXPONENT 0))    ;Mainly for looks sake
  247.     (DUMP-BOXER-THING MANTISSA STREAM)
  248.     (DUMP-BOXER-THING EXPONENT STREAM)))
  249.  
  250. (DEFUN DUMP-STRING (STRING STREAM)
  251.   (ENTER-TABLE STRING)
  252.   (LET ((LENGTH (STRING-LENGTH STRING)))
  253.     (IF (< LENGTH %%BIN-OP-IM-ARG-SIZE)
  254.     (TELL STREAM :TYO (DPB BIN-OP-STRING-IMMEDIATE %%BIN-OP-HIGH LENGTH))
  255.     (TELL STREAM :TYO BIN-OP-STRING)
  256.     (DUMP-BOXER-THING LENGTH STREAM))
  257.     (LOOP FOR I FROM 0 BELOW (BOOLE 2 1 LENGTH) BY 2    ;TV:ALU-ANDCA
  258.       DO (FUNCALL STREAM ':TYO (DPB (AREF STRING (1+ I)) 1010 (AREF STRING I)))
  259.       FINALLY (AND ( I LENGTH)
  260.                (FUNCALL STREAM ':TYO (AREF STRING I))))))
  261.  
  262. ;; this is gross.  It should be  handled by DUMP-LIST.  If you can figure out how to do it
  263. ;; right. then do it. 
  264. (DEFUN DUMP-SIMPLE-CONS (CONZ STREAM)
  265.   (ENTER-TABLE CONZ)
  266.   (TELL STREAM :TYO BIN-OP-SIMPLE-CONS)
  267.   (DUMP-BOXER-THING (CAR CONZ) STREAM)
  268.   (DUMP-BOXER-THING (CDR CONZ) STREAM))
  269.  
  270. ;; this assumes that all lists want to get dumped as they are (i.e. EVALed at dump time)
  271. (DEFUN DUMP-LIST (LIST STREAM)
  272.   (ENTER-TABLE LIST)
  273.   (LOOP FOR L ON LIST
  274.     COUNT T INTO LENGTH
  275.     AS DOTIFY = (ATOM L)
  276.     UNTIL DOTIFY
  277.     FINALLY (IF (< LENGTH %%BIN-OP-IM-ARG-SIZE)
  278.             (FUNCALL STREAM ':TYO
  279.                  (DPB BIN-OP-LIST-IMMEDIATE %%BIN-OP-HIGH LENGTH))
  280.             (FUNCALL STREAM ':TYO BIN-OP-LIST)
  281.             (DUMP-BOXER-THING LENGTH STREAM))
  282.     (LOOP FOR I FROM 0 BELOW LENGTH
  283.           FOR L = LIST THEN (CDR L)
  284.           DO (DUMP-BOXER-THING (IF (AND DOTIFY (= I (1- LENGTH))) L (CAR L))
  285.                    STREAM))))
  286.  
  287. (DEFUN DUMP-ARRAY (ARRAY STREAM)    
  288.   (ENTER-TABLE ARRAY)
  289.   (MULTIPLE-VALUE-BIND (DIMENSIONS OPTIONS)
  290.       (DECODE-ARRAY ARRAY)
  291.     (IF (GET (LOCF OPTIONS) ':DISPLACED-TO)
  292.     (DUMP-ARRAY-1 STREAM DIMENSIONS OPTIONS)
  293.     (LET ((LENGTH (ARRAY-LENGTH ARRAY))    ;Flattened size
  294.           (N-BITS (CDR (ASSQ (GET (LOCF OPTIONS) ':TYPE) ARRAY-BITS-PER-ELEMENT))))
  295.       (COND ((NULL N-BITS)            ;Q type array
  296.          (TELL STREAM :TYO BIN-OP-INITIALIZE-AND-RETURN-ARRAY)
  297.          (DUMP-ARRAY-1 STREAM DIMENSIONS OPTIONS)
  298.          (DUMP-BOXER-THING LENGTH STREAM)
  299.          (LET ((Q-ARRAY (IF (ATOM DIMENSIONS)
  300.                     ARRAY
  301.                     (MAKE-ARRAY LENGTH ':DISPLACED-TO ARRAY))))
  302.            (DOTIMES (I LENGTH)
  303.              (DUMP-BOXER-THING (AREF Q-ARRAY I) STREAM))
  304.            (OR (EQ ARRAY Q-ARRAY) (RETURN-ARRAY Q-ARRAY))))
  305.         (T
  306.          (LET ((16-ARRAY (IF (AND (ATOM DIMENSIONS) (= N-BITS 16.) )
  307.                      ARRAY
  308.                      (SETQ LENGTH (// (+ (* LENGTH N-BITS) 15.) 16.))
  309.                      (MAKE-ARRAY LENGTH ':TYPE 'ART-16B
  310.                          ':DISPLACED-TO ARRAY))))
  311.            (TELL STREAM :TYO BIN-OP-INITIALIZE-AND-RETURN-NUMERIC-ARRAY)
  312.            (DUMP-ARRAY-1 STREAM DIMENSIONS OPTIONS)
  313.            (DUMP-BOXER-THING LENGTH STREAM)
  314.            (FUNCALL STREAM ':STRING-OUT 16-ARRAY 0 LENGTH)
  315.            (OR (EQ ARRAY 16-ARRAY) (RETURN-ARRAY 16-ARRAY)))))))))
  316.  
  317. (DEFUN DUMP-ARRAY-1 (STREAM DIMENSIONS OPTIONS)
  318.   (FUNCALL STREAM ':TYO (DPB BIN-OP-ARRAY %%BIN-OP-HIGH (// (LENGTH OPTIONS) 2)))
  319.   (DUMP-BOXER-THING DIMENSIONS STREAM)
  320.   (DOLIST (FORM OPTIONS)
  321.     (DUMP-BOXER-THING FORM STREAM)))
  322.  
  323. #-3600
  324. (DEFVAR *BOOLEAN-TYPE-ARRAYS* NIL)
  325.  
  326. (DEFUN DECODE-ARRAY (ARRAY &AUX DIMENSIONS OPTIONS)
  327.   (DECLARE (VALUES DIMENSIONS ARRAY-OPTIONS))
  328.   (SETQ DIMENSIONS (IF (= (#-LMITI ARRAY-#-DIMS #+LMITI ARRAY-RANK ARRAY) 1) (ARRAY-LENGTH ARRAY)
  329.                (ARRAY-DIMENSIONS ARRAY)))    
  330.   (LET ((TYPE (ARRAY-TYPE ARRAY)))
  331.     (OR (EQ TYPE 'ART-Q)
  332.     (SETQ OPTIONS `(:TYPE ,TYPE . ,OPTIONS))))
  333.   (AND (ARRAY-HAS-LEADER-P ARRAY)
  334.        (SETQ OPTIONS `(:LEADER-LIST ,(LIST-ARRAY-LEADER ARRAY) . ,OPTIONS)))
  335.   (AND (NAMED-STRUCTURE-P ARRAY)
  336.        (SETQ OPTIONS `(:NAMED-STRUCTURE-SYMBOL ,(#-LMITI NAMED-STRUCTURE-SYMBOL
  337.                          #+LMITI NAMED-STRUCTURE-P ARRAY) . ,OPTIONS)))
  338.   (AND (ARRAY-DISPLACED-P ARRAY)
  339.        (LET ((TEM (SI:ARRAY-INDEX-OFFSET ARRAY)))
  340.      (SETQ OPTIONS `(:DISPLACED-TO ,(SI:ARRAY-INDIRECT-TO ARRAY)
  341.              ,@(AND TEM `(:DISPLACED-INDEX-OFFSET ,TEM))
  342.              . ,OPTIONS))))
  343.   #-3600
  344.   (AND (MEMQ ARRAY *BOOLEAN-TYPE-ARRAYS*)
  345.        (PUTPROP (LOCF OPTIONS) 'SI:ART-BOOLEAN ':TYPE))
  346.   (VALUES DIMENSIONS OPTIONS))
  347.  
  348. ;;; never gets called since they are dumped as fixnums first.  Oh well...
  349. (DEFUN DUMP-CHA (CHA STREAM)
  350.   (TELL STREAM :TYO (DPB BIN-OP-CHA-IMMEDIATE %%BIN-OP-HIGH CHA)))
  351.  
  352. (DEFUN DUMP-ROW (ROW STREAM)
  353.   (ENTER-TABLE ROW STREAM T)
  354.   (TELL ROW :DUMP-SELF STREAM))
  355.  
  356. (DEFMETHOD (ROW :DUMP-SELF) (STREAM)
  357.   (LET* ((CHAS (TELL SELF :CHAS))
  358.      (LENGTH (LENGTH CHAS)))
  359.     (IF (< LENGTH %%BIN-OP-IM-ARG-SIZE)
  360.     (TELL STREAM :TYO (DPB BIN-OP-ROW-IMMEDIATE %%BIN-OP-HIGH LENGTH))
  361.     (TELL STREAM :TYO BIN-OP-ROW)
  362.     (DUMP-BOXER-THING LENGTH STREAM))
  363.     (LOOP FOR CHA IN CHAS
  364.       DO (DUMP-BOXER-THING CHA STREAM))))
  365.  
  366. (DEFMETHOD (NAME-ROW :DUMP-SELF) (STREAM)
  367.   (LET* ((CHAS (TELL SELF :CHAS))
  368.      (LENGTH (LENGTH CHAS)))
  369.     (IF (< LENGTH %%BIN-OP-IM-ARG-SIZE)
  370.     (TELL STREAM :TYO (DPB BIN-OP-NAME-ROW-IMMEDIATE %%BIN-OP-HIGH LENGTH))
  371.     (TELL STREAM :TYO BIN-OP-NAME-ROW)
  372.     (DUMP-BOXER-THING LENGTH STREAM))
  373.     (DUMP-BOXER-THING CACHED-NAME STREAM)
  374.     (LOOP FOR CHA IN CHAS
  375.       DO (DUMP-BOXER-THING CHA STREAM))))
  376.  
  377. ;(DEFMETHOD (NAME-AND-INPUT-ROW :DUMP-SELF) (STREAM)
  378. ;  (LET* ((CHAS (TELL SELF :CHAS))
  379. ;     (LENGTH (LENGTH CHAS)))
  380. ;    (IF (< LENGTH %%BIN-OP-IM-ARG-SIZE)
  381. ;    (TELL STREAM :TYO (DPB BIN-OP-NAME-AND-INPUT-ROW-IMMEDIATE %%BIN-OP-HIGH LENGTH))
  382. ;    (TELL STREAM :TYO BIN-OP-NAME-AND-INPUT-ROW)
  383. ;    (DUMP-BOXER-THING LENGTH STREAM))
  384. ;    (DUMP-BOXER-THING CACHED-NAME STREAM)
  385. ;    (LOOP FOR CHA IN CHAS
  386. ;      DO (DUMP-BOXER-THING CHA STREAM))))
  387.  
  388. ;;; Graphics dumping functions
  389.  
  390. (DEFUN DUMP-GRAPHICS-SHEET (SHEET STREAM)
  391.   (ENTER-TABLE SHEET)
  392.   (TELL STREAM :TYO BIN-OP-GRAPHICS-SHEET)
  393.   (DUMP-BOXER-THING (GRAPHICS-SHEET-DRAW-WID SHEET) STREAM)
  394.   (DUMP-BOXER-THING (GRAPHICS-SHEET-DRAW-HEI SHEET) STREAM)
  395.   (DUMP-BOXER-THING (GRAPHICS-SHEET-BIT-ARRAY SHEET) STREAM)
  396.   (DUMP-BOXER-THING (GRAPHICS-SHEET-DRAW-MODE SHEET) STREAM)
  397.   ;(DUMP-BOXER-THING (GRAPHICS-SHEET-OBJECT-LIST SHEET) STREAM)
  398.   )
  399.  
  400. (DEFUN DUMP-GRAPHICS-OBJECT (OBJECT STREAM)
  401.   (ENTER-TABLE OBJECT STREAM T)
  402.   (TELL STREAM :TYO BIN-OP-GRAPHICS-OBJECT)
  403.   (DUMP-BOXER-THING (TELL OBJECT :DUMP-FORM) STREAM))
  404.  
  405. (DEFUN DUMP-TURTLE (TURTLE STREAM)
  406.   (ENTER-TABLE TURTLE STREAM T)
  407.   (TELL STREAM :TYO BIN-OP-TURTLE)
  408.   (DUMP-BOXER-THING (TELL TURTLE :DUMP-FORM) STREAM))
  409.  
  410. ;;; box dumping methods.  We will rely upon method combination to generate the right set
  411. ;;; of fixnums to dump.  
  412. ;;; Specifically, each type of box has a main method which dumps values specific to the box
  413. ;;; type (i.e. bit-arrays for graphics boxes)
  414. ;;; Things that ALL boxes have to do are dumped by :BEFORE and :AFTER methods
  415. ;;; for vanilla boxes
  416. ;;; The correct BOX-BIN-OP is dumped by specific :BEFORE methods for each type of box
  417. ;;; We have to be careful with boxes that are built out of more than one level of box flavor
  418.  
  419. (DEFUN DUMP-BOX (BOX STREAM)
  420.   (ENTER-TABLE BOX STREAM T)
  421.   (TELL BOX :DUMP-SELF STREAM))
  422.  
  423. ;;; :BEFORE methods
  424.  
  425. (DEFMETHOD (DOIT-BOX :BEFORE :DUMP-SELF) (STREAM)
  426.   (TELL STREAM :TYO BIN-OP-DOIT-BOX))
  427.  
  428. (DEFMETHOD (DATA-BOX :BEFORE :DUMP-SELF) (STREAM)
  429.   (TELL STREAM :TYO BIN-OP-DATA-BOX))
  430.  
  431. (DEFMETHOD (PORT-BOX :BEFORE :DUMP-SELF) (STREAM)
  432.   (TELL STREAM :TYO BIN-OP-PORT-BOX))
  433.  
  434. (DEFMETHOD (GRAPHICS-BOX :BEFORE :DUMP-SELF) (STREAM)
  435.   (TELL STREAM :TYO BIN-OP-GRAPHICS-BOX))
  436.  
  437.  (DEFMETHOD (GRAPHICS-DATA-BOX :BEFORE :DUMP-SELF) (STREAM)
  438.   (TELL STREAM :TYO BIN-OP-GRAPHICS-DATA-BOX))
  439.  
  440. (DEFMETHOD (SPRITE-BOX :BEFORE :DUMP-SELF) (STREAM)
  441.   (TELL STREAM :TYO BIN-OP-SPRITE-BOX))
  442.  
  443. (DEFMETHOD (LL-BOX :BEFORE :DUMP-SELF) (STREAM)
  444.   (TELL STREAM :TYO BIN-OP-LL-BOX))
  445.  
  446. ;;; these DEFUN-METHOD's are for error catching and  making it easy to change formats
  447. ;;; for things like the binding scheme
  448.  
  449. (DEFUN-METHOD DUMP-BOX-NAME BOX (STREAM)
  450.   (COND ((OR (STRINGP NAME) (NAME-ROW? NAME))
  451.      (DUMP-BOXER-THING NAME STREAM))
  452.     ((AND (SYMBOLP NAME) (EQ (SYMBOL-PACKAGE NAME) PKG-BU-PACKAGE))
  453.      (DUMP-BOXER-THING (MAKE-NAME-ROW (LIST (GET-PNAME NAME)) NAME) STREAM))
  454.     ((NULL NAME)
  455.      (DUMP-BOXER-THING NAME STREAM))
  456.     (T
  457.      (FERROR
  458.        "Incompatible change, the instance var name, ~S is not a string or row" NAME))))
  459.  
  460. (DEFUN-METHOD DUMP-DISPLAY-STYLE BOX (STREAM)
  461.   (IF (LISTP DISPLAY-STYLE-LIST)
  462.       (DUMP-BOXER-THING DISPLAY-STYLE-LIST STREAM)
  463.       (FERROR "Incompatible change, the instance variable DISPLAY-STYLE-LIST is no longer a list")))
  464.  
  465. (DEFUN-METHOD DUMP-ENVIRONMENT BOX (STREAM)
  466.   (LET ((OLD-ENVIRONMENT STATIC-VARIABLES-ALIST))
  467.     (IF (OR (NULL STATIC-VARIABLES-ALIST) (LISTP STATIC-VARIABLES-ALIST))
  468.     (DUMP-BOXER-THING
  469.       ;;if the box points to itself, we remove the binding before dumping
  470.       ;; cause it will lose
  471.       (DELQ (RASSQ SELF STATIC-VARIABLES-ALIST) STATIC-VARIABLES-ALIST)
  472.       STREAM)
  473.     (FERROR "Incompatible change, the instance variable STATIC-VARIABLES-ALIST is no longer a list"))
  474.     (SETQ STATIC-VARIABLES-ALIST OLD-ENVIRONMENT)))
  475.  
  476. (DEFUN-METHOD DUMP-LOCAL-LIBRARY BOX (STREAM)
  477.   (IF (NOT (OR (LL-BOX? LOCAL-LIBRARY) (NULL LOCAL-LIBRARY)))
  478.     ;; if it isn't one or the other, then some things in the loader will break also
  479.       (FERROR "unrecognized local library format")
  480.       (TELL STREAM :TYO BIN-OP-LL-BOX-PRESCENCE-MARKER)
  481.       (DUMP-BOXER-THING LOCAL-LIBRARY STREAM)))
  482.  
  483. (DEFMETHOD (BOX :BEFORE :DUMP-SELF) (STREAM)
  484.   (DUMP-BOX-NAME STREAM)
  485.   (DUMP-DISPLAY-STYLE STREAM)
  486.   (DUMP-ENVIRONMENT STREAM)
  487.   (DUMP-LOCAL-LIBRARY STREAM))
  488.  
  489. ;;; MAIN methods
  490.                            
  491. (DEFMETHOD (BOX :DUMP-SELF) (STREAM)        ;for DATA and DOIT boxes
  492.     ;; move to BOX :BEFORE method if we allow ports to graphics boxes
  493.     (LOOP FOR ROW IN (TELL SELF :ROWS)
  494.       DO (DUMP-BOXER-THING ROW STREAM)))
  495.  
  496. (DEFMETHOD (PORT-BOX :DUMP-SELF) (STREAM)
  497.   ;; all we have to do now is to dump the ported to box
  498.   (COND ((NULL PORTS) (cl:cerror #.(cl:string "Continue Saving Anyway")
  499.                  #.(cl:string "Can't find ported to box")))
  500.     ((TELL PORTS :SUPERIOR? *OUTERMOST-DUMPING-BOX*)
  501.      (DUMP-BOXER-THING PORTS STREAM))
  502.     (T (cl:cerror #.(cl:string "Continue Saving Anyway")
  503.               #.(cl:string "The ported to box, ~S, will not get dumped") PORTS))))
  504.  
  505. (DEFMETHOD (GRAPHICS-BOX :DUMP-SELF) (STREAM)
  506.   (DUMP-BOXER-THING GRAPHICS-SHEET STREAM)
  507.   (LOOP FOR ROW IN (TELL SELF :ROWS)
  508.       DO (DUMP-BOXER-THING ROW STREAM)))
  509.  
  510. (DEFMETHOD (GRAPHICS-DATA-BOX :DUMP-SELF) (STREAM)
  511.    (DUMP-BOXER-THING GRAPHICS-SHEET STREAM)
  512.    (LOOP FOR ROW IN (TELL SELF :ROWS)
  513.       DO (DUMP-BOXER-THING ROW STREAM)))
  514.  
  515. (DEFMETHOD (SPRITE-BOX :DUMP-SELF) (STREAM)
  516.   (DUMP-BOXER-THING ASSOCIATED-TURTLE STREAM)
  517.   (LOOP FOR ROW IN (TELL SELF :ROWS)
  518.       DO (DUMP-BOXER-THING ROW STREAM)))
  519.  
  520. (DEFMETHOD (BOX :AFTER :DUMP-SELF) (STREAM)
  521.   (DUMP-BOXER-THING EXPORTS STREAM)
  522.   (TELL STREAM :TYO BIN-OP-END-OF-BOX))
  523.  
  524.